home *** CD-ROM | disk | FTP | other *** search
/ MacTech 1 to 12 / MacTech-vol-1-12.toast / Source / MacTech® Magazine / Volume 03 - 1987 / 03.09 Sep 87 / fortran source / ctlprc stuff / ctlprc.asm next >
Encoding:
Assembly Source File  |  1987-08-09  |  5.4 KB  |  192 lines  |  [TEXT/EDIT]
  1. ; Listing 3
  2. ; ctlprc.sub source code
  3. ; Provided by Absoft Tech Support
  4. ;
  5. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  6. ;
  7. ; Title: Toolbox Control/Filter glue procedure.
  8. ;
  9. ; Produced by: Absoft Soft, Inc.                        Date:  8/19/86
  10. ;
  11. ; Purpose: To interface MacFortran with the Macintosh's Toolbox.
  12. ;
  13. ; Notes: This procedure takes a FORTRAN procedure as an argument and returns
  14. ;    a pointer to a procedure that can be called by the Macintosh
  15. ;    toolbox.  This is used to allow control tracking and filter procedures
  16. ;    to be written in FORTRAN.
  17. ;
  18. ; Warnings/Limitations:  This procedure locks itself into the FORTRAN heap
  19. ;    when it is called for the first time.  Since it returns pointers
  20. ;    to locations within itself, it must never move.  It should
  21. ;    therefore be called as the first executable
  22. ;    statement in the main program.  If it is not desireable to set
  23. ;    up the procedure pointers at the begining of the main program,
  24. ;    ctlprc can also be called with a zero for the procedure argument:
  25. ;
  26. ;    DUMMY = CTLPRC(0, 0)
  27. ;
  28. ;    This will lock the subroutine in memory without setting up a
  29. ;    procedure.
  30. ;
  31. ; Calling sequence:
  32. ;    <procedure pointer> = CTLPRC(<filter proc>, <argument byte count>)
  33. ;   where
  34. ;    <procedure pointer> is a FORTRAN INTEGER variable.  This will
  35. ;        be assigned a pointer to a procedure.  This variable
  36. ;        is then used as the filter procedure parameter in calls
  37. ;        to the toolbox.
  38. ;    <filter proc> is the name of the FORTRAN procedure to be called
  39. ;        from the toolbox.  This should be a procedure with a single
  40. ;        integer parameter, which on entry will contain a pointer to
  41. ;        the arguments from the toolbox as they appear on the stack.
  42. ;        This must be declared as EXTERNAL in the program unit where
  43. ;        CTLPRC is used; this will usually be the main program.
  44. ;    <argument byte count> is the total number of bytes of arguments that
  45. ;        the toolbox will push on the stack for the type of filter
  46. ;        procedure that this FORTRAN procedure will be used for.
  47. ;        For example, if the procudure is to be used to track a scroll
  48. ;        bar, the toolbox will pass 2 parameters on the stack; the 
  49. ;        control handle (4 bytes) and the part code (2 bytes), for
  50. ;        a total of 6 bytes.  The track procdure should be initialized
  51. ;        with
  52. ;            INTEGER TRACK
  53. ;            .
  54. ;            .
  55. ;            .
  56. ;            TRACK = CTLPRC(FTRACK, 6)
  57. ;        where FTRACK is the FORTRAN procedure name.  The integer
  58. ;        variable TRACK will contain the address of a toolbox callable
  59. ;        procedure.  A maximum of 16 procedures can be set up by
  60. ;        ctlprc.  When this limit is reached, ctlprc will return
  61. ;        a zero instead of a procedure pointer.
  62. ;
  63. ;
  64. ; Modification History:
  65. ;    
  66. ;   30 OCT 86    Saved and tested D0 for register based ctl procs.    RTC
  67. ;
  68. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  69.  
  70.         INCLUDE TOOLEQU.D
  71.  
  72. CTLPRC:    LEA    4(A7),A4        ; Load the original Stack Pointer...
  73.     LEA     CTLPRC(PC),A5           ; Get the execution address.
  74.         CMPA.L  A0,A5                   ; Test to see if we are loaded in heap
  75.         BMI.S   L1                      ; If linked avoid the set.
  76.         MOVE.W  #1,-8(A1)               ; Mark this routine PERMENANT.
  77. L1:    MOVE.L    A0,APPLSCRATCH+4    ; Save impure pointer.
  78.     LEA    NXTPRC,A2        ; Get address of next routine ptr.
  79.     MOVE.L    (A2),D0            ; Get offset to next routine.
  80.     LEA    PRCTBL,A1        ; Get pointer to procedure table.
  81.     ADD.L    D0,A1            ; Point to next procedure.
  82.     CLR.L    D0            ; Flag no room.
  83.     LEA    ENDPRC,A3        ; Get address of end of table.
  84.     CMPA.L    A3,A2            ; Any room left?
  85.     BGE.S    NOROOM            ;   no
  86.     MOVE.L    A1,D0            ; Return procedure pointer.
  87.     MOVE.L    (A4)+,A5        ; Get a pointer to the count.
  88.     MOVE.L    (A5),D1            ; Get the argument byte count.
  89.     ADDQ.W    #2,A1            ; Bypass the BSR.S instruction.
  90.     MOVE.W    D1,(A1)+        ; Store the argument byte count.
  91.     MOVE.L    (A4)+,A5        ; Get pointer to the proc. ptr.
  92.     MOVE.L    (A5)+,(A1)+        ; Store the procedure pointer.
  93.     BNE.S    OKPROC            ; Not nil - update the offset.
  94.     MOVEQ    #0,D0            ; Nil procedure - flag not installed.
  95.     BRA.S    NOROOM            ; Do not update offset.
  96. OKPROC:    ADDI.L    #8,(A2)            ; Offset to next procedure.
  97. NOROOM:    RTS
  98.  
  99.  
  100. NXTPRC:    DC.L    0
  101.  
  102. PRCTBL:    BSR.S    GLUE
  103.     DC.W    0
  104.     DC.L    0
  105.  
  106.     BSR.S    GLUE
  107.     DC.W    0
  108.     DC.L    0
  109.  
  110.     BSR.S    GLUE
  111.     DC.W    0
  112.     DC.L    0
  113.  
  114.     BSR.S    GLUE
  115.     DC.W    0
  116.     DC.L    0
  117.  
  118.     BSR.S    GLUE
  119.     DC.W    0
  120.     DC.L    0
  121.  
  122.     BSR.S    GLUE
  123.     DC.W    0
  124.     DC.L    0
  125.  
  126.     BSR.S    GLUE
  127.     DC.W    0
  128.     DC.L    0
  129.  
  130.     BSR.S    GLUE
  131.     DC.W    0
  132.     DC.L    0
  133.  
  134.     BSR.S    GLUE
  135.     DC.W    0
  136.     DC.L    0
  137.  
  138.     BSR.S    GLUE
  139.     DC.W    0
  140.     DC.L    0
  141.  
  142.     BSR.S    GLUE
  143.     DC.W    0
  144.     DC.L    0
  145.  
  146.     BSR.S    GLUE
  147.     DC.W    0
  148.     DC.L    0
  149.  
  150.     BSR.S    GLUE
  151.     DC.W    0
  152.     DC.L    0
  153.  
  154.     BSR.S    GLUE
  155.     DC.W    0
  156.     DC.L    0
  157.  
  158.     BSR.S    GLUE
  159.     DC.W    0
  160.     DC.L    0
  161.  
  162.     BSR.S    GLUE
  163.     DC.W    0
  164.     DC.L    0
  165. ENDPRC:
  166.  
  167.  
  168. GLUE:    MOVE.L    A7,A1            ; Save pointer to procedure info.
  169.     MOVEM.L    D2-D7/A2-A5,-(A7)    ; Save the world.
  170.     MOVE.L    APPLSCRATCH+4,A0    ; Restore impure pointer.
  171.     MOVE.L    (A0),A4            ; Restore runtime library pointer.
  172.     LINK    A6,#-1024        ; Get an arithmetic stack.
  173.     LEA    -4(A6),A5        ; Put math stack in A5.
  174.     MOVE.L    (A1),A2            ; Get pointer to proc. info.
  175.     MOVE.W    (A2)+,-(A7)        ; Save the argument byte count.
  176.     MOVE.L    (A2),A2            ; Get the procedure address.
  177.     PEA    8(A1)            ; Push a pointer to the arguments.
  178.     MOVE.L    A7,-(A7)        ; Push a pointer to the arg. pointer.
  179.     JSR    (A2)            ; Call the FORTRAN procedure.
  180.     ADDQ.W    #8,A7            ; Push argument to FORTRAN proc.
  181.     MOVE.W    (A7)+,D1        ; Get the argument byte count.
  182.     UNLK    A6            ; Return aritmetic stack.
  183.     MOVEM.L    (A7)+,D2-D7/A2-A5    ; Restore the world.
  184.     ADDQ.W    #4,A7            ; Bypass pointer to procedure info.
  185.     MOVE.L    (A7)+,A1        ; Save return address.
  186.     ADD.W    D1,A7            ; Pop arguments.
  187.     TST.W    D0            ; Set the condition codes.
  188.     JMP    (A1)            ; Return to the toolbox.
  189.  
  190.     END
  191.  
  192.